home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Yerk 3.64 ƒ / tool+ / popupctl next >
Encoding:
Text File  |  1993-06-23  |  2.9 KB  |  96 lines  |  [TEXT/ttxt]
  1. \  5/26/93    rfl    System 7 support for PopUpMenus...doesn't work for <7.
  2. \                See popUpMenu6 for <7 support.
  3.  
  4. :CLASS popUpMenu <super Control 4 <indexed
  5.  
  6.     rect bounds
  7.     int    valueParm
  8.  
  9.   :M handle: ptr: ctlhndl 28 + @ -base @ -base @ ;M
  10.  
  11.   :M putRect: put: bounds ;M
  12.  
  13. \ *** next three methods apply to the Title box, not the popup ***
  14.  
  15. \ 0=left;1=center;255=right
  16.   :M justify: ( n --) get: valueParm $ ff00 and or put: valueParm ;M
  17.  
  18. \ $100=bold;$200=italic;$400=underline;$800=outline;$1000=shadow
  19.   :M face: ( n --) get: valueParm $ e0ff and or put: valueParm ;M
  20.  
  21. \ $2000=condense;$4000=extend;$8000=nostyle
  22.   :M style: ( n --) get: valueParm $ 1fff and or put: valueParm ;M
  23.  
  24. \ build a popup; procid is set to 1=fixedwidth;4=addresmen;8=useWFont
  25.     :M  NEW:  { x y addr len theWind \ tWid -- }
  26.         theWind saveFont
  27.         get: procID 8 and 0=
  28.         IF 0 tFont 12 tSize THEN addr len tWidth -> tWid    \ width of title
  29.         0 abs: theWind  Abs: bounds addr len str255
  30.         w 256 int: valueParm int: resId twid makeint  1008 get: procId +
  31.         makeInt  ^base
  32.         call NewControl put: ctlhndl
  33.         ^base get: ctlhndl set-ctl-obj
  34.         theWind put: myWindow theWind restFont ;M
  35.  
  36. \      :M getnew: { \ theWind -- } get: myWindow -> theWind
  37. \         theWind 0= classerr" 157 theWind saveFont
  38. \         0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  39. \         put: ctlhndl
  40. \         ^base get: ctlhndl set-ctl-obj
  41. \         theWind put: myWindow get: myValue put: self theWind restFont ;M
  42.  
  43.   :M size: handle: self >ptr 22 + w@ ;M
  44.  
  45.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  46.     :M  PUT:     Put: ResId   Put: Super  ;M
  47.  
  48.     :M  PUTITEM: { theVal -- } alive: [ obj: myWindow ]
  49.         IF theVal put: super THEN
  50.         theVal put: myValue ;M
  51.  
  52.     :M  GETITEM: ( -- item) alive: [ obj: myWindow ]
  53.         IF get: super dup put: myValue ELSE get: myValue THEN ;M
  54.  
  55.     :M  EXEC: ( part# --)
  56.         IF getItem: self -> mitem
  57.            ^base -> theMenu get: resID -> menuID
  58.             mitem 1- at: self execute exec: action
  59.         THEN ;M
  60.  
  61.     \ ( item# -- addr len )  get string for item #
  62.     :M  GET:  ( item -- addr len ) handle: self  swap makeInt
  63.         buf255 +base  call GetItem  buf255 count ;M
  64.  
  65.     :M  GETNAME: ( -- addr len) handle: self >ptr 14 + count ;M
  66.  
  67.     \ ( addr len -- )  Append a menu item
  68.     :M  ADD:   Str255  handle: self ?new swap  call AppendMenu  ;M
  69.  
  70.     \ ( addr len item# -- )  replace menu item string
  71.     :M  SET:   >r str255 >r handle: self ?new
  72.         r> r> swap >r makeInt r> call SetItem draw: [ obj: myWindow ] ;M
  73.  
  74.     \ ( item# -- )  Enable a menu item
  75.     :M  ENABLE: handle: self swap makeInt call EnableItem draw: [ obj: myWindow ] ;M
  76.  
  77.     \ ( item# -- )  Grey and disable an item
  78.     :M  DISABLE: handle: self swap makeInt call DisableItem draw: [ obj: myWindow ] ;M
  79.  
  80.     :M  CHECKED?: ( item -- b) get: super = ;M
  81. ;CLASS
  82.  
  83.  
  84. \ Example:
  85. \ ctlwind suz
  86. \ example: suz setlimits: suz
  87. \ " .rsrc" openresfile
  88. \ 
  89. \ 5 popupmenu bob
  90. \ 100 50 300 69 putrect: bob
  91. \ 128 putresid: bob
  92. \ 100 50 "  " suz new: bob
  93. \ 
  94. \ : one mitem home . ;
  95. \ 'c one fill: bob
  96.